home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 February: Tool Chest / Apple Developer CD Series Tool Chest February 1996 (Apple Computer)(1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / User Contributions / zebu v3.3.3 (LALR parser) / zebu-mg-hierarchy.lisp < prev    next >
Encoding:
Text File  |  1994-09-12  |  5.1 KB  |  176 lines  |  [TEXT/ttxt]
  1. ; -*- mode:     CL -*- ----------------------------------------------------- ;
  2. ; File:         zebu-mg-hierarchy.l
  3. ; Description:  types and printers for the meta grammar
  4. ; Author:       Joachim H. Laubsch
  5. ; Created:      13-May-92
  6. ; Modified:     Mon May 17 16:21:06 1993 (Joachim H. Laubsch)
  7. ; Language:     CL
  8. ; Package:      ZEBU
  9. ; Status:       Experimental (Do Not Distribute) 
  10. ; RCS $Header: $
  11. ;
  12. ; (c) Copyright 1992, Hewlett-Packard Company
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14. ; Revisions:
  15. ; RCS $Log: $
  16. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  17. (in-package "ZEBU")
  18. (provide "zebu-mg-hierarchy")
  19. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  20. ;;                   Top of hierarchy for ZEBU META-Grammar
  21. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  22.  
  23.  
  24. (DEFSTRUCT (ZEBU-MG (:INCLUDE KB-DOMAIN)
  25.                     (:CONSTRUCTOR NIL)))
  26.  
  27. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  28. ;;                                 KB-SEQUENCE
  29. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  30.  
  31. (defvar *kb-sequence-separator* " "
  32.   "A string, separating the elements of a KB-sequence")
  33.  
  34. (defstruct (KB-SEQUENCE (:include ZEBU-MG)
  35.             (:print-function KB-SEQUENCE-print)) 
  36.   first
  37.   (rest nil :type (or NULL KB-SEQUENCE)))
  38.  
  39. (defun KB-SEQUENCE-print (ITEM STREAM LEVEL)
  40.   (DECLARE (IGNORE LEVEL))
  41.   (if (KB-SEQUENCE-p ITEM)
  42.       (let ((first (KB-SEQUENCE-first ITEM))
  43.         (rest  (KB-SEQUENCE-rest ITEM)))
  44.     (if (null rest)
  45.         (format STREAM "~a" first)
  46.       (if (kb-sequence-p rest)
  47.           (format STREAM "~a~:{~A~a~}"
  48.               first
  49.               (labels ((cons-kb-seq (seq)
  50.                  (if (null seq)
  51.                      nil
  52.                    (cons (list *kb-sequence-separator*
  53.                            (KB-SEQUENCE-first seq))
  54.                      (cons-kb-seq
  55.                       (KB-SEQUENCE-rest seq))))))
  56.             (cons-kb-seq rest)))
  57.         (format STREAM "~a~A~a" first *kb-sequence-separator* rest))))
  58.     ""))
  59.  
  60. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  61. ;;                                  FEAT-TERM
  62. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  63.  
  64. (DEFSTRUCT (FEAT-TERM (:INCLUDE Zebu-mg)
  65.               #||
  66.               (:print-function
  67.                (lambda (ITEM STREAM LEVEL)
  68.              (DECLARE (IGNORE LEVEL))
  69.              (format STREAM
  70.                  "~@[type: ~S ~][~{~S~^ ~}]"
  71.                  (FEAT-TERM--type ITEM)
  72.                  (FEAT-TERM--slots ITEM))))
  73.               ||#
  74.               )
  75.   -TYPE
  76.   (-SLOTS nil))
  77.  
  78. (DEFSTRUCT (LABEL-VALUE-PAIR (:INCLUDE ZEBU-MG)
  79.                  #||
  80.                  (:print-function
  81.                   (lambda (ITEM STREAM LEVEL)
  82.                 (DECLARE (IGNORE LEVEL))
  83.                 (format STREAM
  84.                     "(~S ~S)"
  85.                     (Label-value-pair--label ITEM)
  86.                     (Label-value-pair--value ITEM))))
  87.                  ||#
  88.                  )
  89.            -LABEL
  90.            (-VALUE nil))
  91.  
  92. #|| Not used yet
  93. (DEFSTRUCT (GENERAL-VAR (:INCLUDE ZEBU-MG)
  94.             #||
  95.             (:print-function
  96.              (lambda (ITEM STREAM LEVEL)
  97.                (DECLARE (IGNORE LEVEL))
  98.                (format STREAM
  99.                    "%~S"
  100.                    (General-Var--name ITEM))))
  101.             ||#
  102.             )
  103.            -NAME)
  104.  
  105. (DEFSTRUCT (TAGGED-TERM (:INCLUDE ZEBU-MG)
  106.             #||
  107.             (:print-function
  108.              (lambda (ITEM STREAM LEVEL)
  109.                (DECLARE (IGNORE LEVEL))
  110.                (format STREAM
  111.                    "~S=~S"
  112.                    (Tagged-Term--tag ITEM)
  113.                    (Tagged-Term--term ITEM))))
  114.             ||#
  115.             )
  116.            -TERM
  117.            -TAG)
  118. ||#
  119.  
  120. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  121. ;;                               PRODUCTION-RHS
  122. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  123.  
  124. (DEFSTRUCT (PRODUCTION-RHS (:INCLUDE ZEBU-MG)
  125.                #||
  126.                (:print-function print-production-rhs)
  127.                ||#
  128.                )
  129.   (-SYNTAX nil)
  130.   (-SEMANTICS nil)
  131.   -BUILD-FN)
  132.  
  133. (defun print-production-rhs (ITEM STREAM LEVEL)
  134.   (DECLARE (IGNORE LEVEL))
  135.   (format STREAM
  136.       "~{~S ~}~@[ { ~S }~];"
  137.       (production-rhs--syntax ITEM)
  138.       (production-rhs--semantics ITEM)))
  139.  
  140. (DEFSTRUCT (Kleene (:INCLUDE ZEBU-MG) )
  141.            -constituent
  142.            -separator)
  143.  
  144. (DEFSTRUCT (Kleene* (:INCLUDE Kleene) ))
  145. (DEFSTRUCT (Kleene+ (:INCLUDE Kleene) ))
  146.  
  147. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  148. ;;                              Type definitions
  149. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  150.  
  151. (defstruct (domain-type (:include zebu-mg))
  152.   -supertype -type -slots print-function)
  153.  
  154. (defun cons-domain-type (name avm print-function)
  155.   ;; Return: [supertype type slots print-function]
  156.   (let ((type (if (feat-term-p avm)
  157.           (feat-term--type avm)
  158.         'KB-Domain))
  159.     (slots (if (feat-term-p avm)
  160.            (feat-term--slots avm)
  161.          avm)))
  162.     (make-domain-type
  163.      :-supertype type
  164.      :-type name
  165.      :-slots (mapcar #'(lambda (slot)
  166.              (let ((v (label-value-pair--value slot)))
  167.                (if (null v)
  168.                    (label-value-pair--label slot)
  169.                  (list (label-value-pair--label slot) v))))
  170.              slots)
  171.      :print-function print-function)))
  172.  
  173. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  174. ;;                        End of zebu-mg-hierarchy.l
  175. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  176.